      SUBROUTINE PK_BMAP(KFILDO,IB,NXY,IPACK,ND5,LOCN,IPOS,
     1                   L3264B,IER,*)
C
C        MARCH   2000   LAWRENCE   GSC/TDL    ORIGINAL CODING
C        MARCH   2000   GLAHN      CHANGED NX*NY TO NXY;
C                                  CHECKED FOR SIZE OF IPACK( );
C                                  CHANGED NAME FROM PKBMAP
C        JANUARY 2001   GLAHN      COMMENTS; MADE STANDARD RETURN;
C                                  CHANGED IER = 601 TO 605
C
C        PURPOSE
C           PACKS A BIT-MAP IN IB( ) INTO IPACK( ).
C
C        DATA SET USE
C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
C
C        VARIABLES
C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE.  (INPUT)
C               IB(K) = CONTAINS THE BITMAP TO BE PACKED.
C                       (K=1,NXY).  (INPUT)
C                 NXY = THE DIMENSIONS OF IB( ).  (INPUT)
C            IPACK(J) = THE ARRAY THAT HOLDS THE ACTUAL PACKED
C                       MESSAGE (J=1,ND5).  (INPUT/OUTPUT)
C                 ND5 = THE SIZE OF THE ARRAY IPACK( ).  (INPUT)
C                LOCN = THE WORD POSITION TO PLACE THE NEXT VALUE.
C                       (INPUT/OUTPUT)
C                IPOS = THE BIT POSITION IN LOCN TO START PLACING
C                       THE NEXT VALUE. (INPUT/OUTPUT)
C              L3264B = THE INTEGER WORD LENGTH IN BITS OF THE MACHINE
C                       BEING USED.  VALUES OF 32 AND 64 ARE
C                       ACCOMMODATED.  (INPUT)
C                 IER = RETURN STATUS CODE. (OUTPUT)
C                         0 = GOOD RETURN.
C                       1-4 = ERROR CODES GENERATED BY PKBG. SEE 
C                             THE DOCUMENTATION IN THE PKBG
C                             ROUTINE.
C                       605 = NOT ENOUGH SPACE IN PACK( ).
C                   * = ALTERNATE ERROR RETURN WHEN IER GE 900.
C
C             LOCAL VARIABLES
C               IFILL = CONTAINS THE NUMBER OF BITS TO BE
C                       ZERO-PADDED TO MAKE THE PACKED BIT-MAP
C                       OCCUPY A WHOLE NUMBER OF OCTETS.
C                   J = LOOP INDEX.
C
C        NON SYSTEM SUBROUTINES CALLED
C           PKBG
C
      DIMENSION IPACK(ND5),IB(NXY)
C
      DATA IZERO/0/
C
      IF(NXY.GT.(L3264B+1-IPOS)+(ND5-LOCN)*L3264B)THEN
         IER=605
C***D       WRITE(KFILDO,103)NXY,LOCN,IPOS,ND5,IER
C***D103     FORMAT(/' NXY = 'I9,' REQUIRES MORE BITS',
C***D    1           ' THAN ARE AVAILABLE IN IPACK( ),',
C***D    2           ' WITH LOCN ='I8,', IPOS ='I4,', AND ND5 ='I8,'.'/
C***D    3           ' RETURN FROM PK_BMAP WITH IER ='I4)
         GO TO 900
      ENDIF
C
      DO J=1,NXY
C
         CALL MVBITS(IB(J),0,1,IPACK(LOCN),L3264B-IPOS)
C
         IF(IPOS.EQ.L3264B)THEN
            IPOS=1
            LOCN=LOCN+1
         ELSE
            IPOS=IPOS+1
         ENDIF
      END DO
C
C        PAD WITH ZEROS TO FILL OUT AN OCTET, IF NECESSARY.
C
      IFILL=MOD(33-IPOS,8)
C
      IF(IFILL.NE.0)THEN
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,IFILL,
     1             L3264B,IER,*900)
      ENDIF
C
C       ERROR RETURN SECTION
C
 900  IF(IER.NE.0)RETURN 1
C
      RETURN
      END
